-- Source code for ISS Joiner (http://issjoiner.codeplex.com)
-- Compilation (needs Glasgow Haskell Compiler): ghc -O2 -optl-s -ojoiner.exe joiner.hs && upx -9 --lzma joiner.exe
import Data.Char
import Data.List
import System.Environment

main = do
  files <- getArgs                                           -- list of filenames
  if null files then putStr (unlines help) else do           -- display help if no parameters given
  texts <- mapM readFile files                               -- list of script texts

  let haveSections = map hasSectionHeader texts              -- which input tests have sections inside
  let cmt     = if (or haveSections) then ";" else "//"      -- comment chars
  let addFooter   | or haveSections = (++ ["\n[Setup]\n"])   -- if we have sections, add [Setup] at the end of each script so next script can use comments before any section
                  | otherwise       = id                     --   otherwise - copy scripts intact
  let addHeader x | or haveSections = addCodeHeader x        -- if any script has sections, then add [Code] header to section-less scripts
                  | otherwise       = id                     --   otherwise - copy all scripts intact

  -- Each script represented as list of Strings that should be concatenated together to give back full script text
  let scripts = map parse texts                              -- list of parsed script texts (each script is split into "words", i.e. indentifiers and text between them)
  let stdids  = map (unique.filter isStdId) scripts          -- list of standard identifiers used in each script
  let disambScripts = zipWith replaceStdIds [1..] scripts    -- disambiguated scripts: with standard identifiers renamed to unique names

  let finalScripts = zipWith (addScriptDescription cmt) files$ zipWith addHeader haveSections$ map addFooter disambScripts   -- add comment with original filename and [Code] header to each script
      dispatcher   = addDispatcherDescription cmt$ addHeader False$ generateDispatchers stdids    -- event dispatcher code

  writeFile "joined.iss" (concat$ concat$ [header cmt] ++ finalScripts ++ [dispatcher])   -- Save joined script to file



help = ["InnoSetup Script Joiner version 3.0, Jul 23 2009, (c) Bulat Ziganshin <Bulat.Ziganshin@gmail.com>.",
        "",
        "This program joins InnoSetup scripts. More info at http://issjoiner.codeplex.com/",
        "",
        "Usage: joiner 11.iss 12.iss 13.iss 14.iss",
        "",
        "The output is written to joined.iss"
       ]

-- |Add header with info about me and my program
header cmt = [cmt++" --- Generated by InnoSetup Script Joiner version 3.0, Jul 23 2009, (c) Bulat Ziganshin <Bulat.Ziganshin@gmail.com>. More info at http://issjoiner.codeplex.com/\n\n"]

-- |Add description to one of scripts being joined
addScriptDescription cmt filename script = [cmt++" --- Source: "++filename++" ------------------------------------------------------------\n"] ++ script ++ ["\n\n"]

-- |Add description to dispatcher code
addDispatcherDescription cmt script = [cmt++" --- Dispatching code ------------------------------------------------------------\n"] ++ script ++ ["\n\n"]


-- |Does this text contain any section header?
hasSectionHeader text = any isHeader (lines text)
  where isHeader line = (take 1 line=="[")  &&  (take 1 (reverse line)=="]")

-- |Add [Code] to the scripts that doesn't have any sections at all
addCodeHeader hasSections@True  = id
addCodeHeader hasSections@False = (["\n[Code]\n"] ++)


-- |Add n to standard identifiers (in order to make them unique)
replaceStdIds :: Int -> [String] -> [String]
replaceStdIds n = map $ \word ->
  if isStdId word
    then word++show n
    else word

-- |Checks that x is one of standard identifiers
isStdId x = x `elem` words "InitializeWizard CurPageChanged CurStepChanged CurUninstallStepChanged DeinitializeSetup RegisterPreviousData InitializeUninstallProgressForm DeinitializeUninstall InitializeSetup NextButtonClick BackButtonClick ShouldSkipPage NeedRestart GetCustomSetupExitCode InitializeUninstall UninstallNeedRestart"

-- |Removes duplicates
unique = nub

-- Splits script text into list of identifiers and texts between them so that concat.parse==id
parse xs | isAlpha (head xs)  =  parseId    "" xs
         | otherwise          =  parseSpace "" xs

parseId h xxs@(x:xs) | isAlphaNum x  =  parseId (x:h) xs
                     | otherwise     =  reverse h : parseSpace "" xxs
parseId h ""                         =  reverse h : []

parseSpace h xxs@(x:xs) | isAlphaNum x  =  reverse h : parseId "" xxs
                        | otherwise     =  parseSpace (x:h) xs
parseSpace h ""                         =  reverse h : []


-- Generate dispatchers for standard procedures
generateDispatchers ids =
  let procs          =  unique (concat ids)                       -- names of procedures to generate
      findNums name  =  map (1+)$ findIndices (name `elem`) ids   -- find numbers of scripts where `name` procedure is present
      generate name  =  generateProc (findNums name) name         -- generate dispatcher for procedure `name` that calls all definitions from the scripts being joined
  in map generate procs

-- Generate dispatcher for some standard procedure (nums are numbers of scripts to call)
generateProc nums name@"InitializeWizard"                = generateBody nums name "proc" "procedure InitializeWizard()"                                         ""
generateProc nums name@"CurPageChanged"                  = generateBody nums name "proc" "procedure CurPageChanged(CurPageID: Integer)"                         "CurPageID"
generateProc nums name@"CurStepChanged"                  = generateBody nums name "proc" "procedure CurStepChanged(CurStep: TSetupStep)"                        "CurStep"
generateProc nums name@"CurUninstallStepChanged"         = generateBody nums name "proc" "procedure CurUninstallStepChanged(CurUninstallStep: TUninstallStep)"  "CurUninstallStep"
generateProc nums name@"DeinitializeSetup"               = generateBody nums name "proc" "procedure DeinitializeSetup()"                                        ""
generateProc nums name@"RegisterPreviousData"            = generateBody nums name "proc" "procedure RegisterPreviousData(PreviousDataKey: Integer)"             "PreviousDataKey"
generateProc nums name@"InitializeUninstallProgressForm" = generateBody nums name "proc" "procedure InitializeUninstallProgressForm()"                          ""
generateProc nums name@"DeinitializeUninstall"           = generateBody nums name "proc" "procedure DeinitializeUninstall()"                                    ""

generateProc nums name@"InitializeSetup"                 = generateBody nums name "and"  "function InitializeSetup(): Boolean"                                  ""
generateProc nums name@"NextButtonClick"                 = generateBody nums name "and"  "function NextButtonClick(CurPageID: Integer): Boolean"                "CurPageID"
generateProc nums name@"BackButtonClick"                 = generateBody nums name "and"  "function BackButtonClick(CurPageID: Integer): Boolean"                "CurPageID"
generateProc nums name@"ShouldSkipPage"                  = generateBody nums name "and"  "function ShouldSkipPage(PageID: Integer): Boolean"                    "PageID"
generateProc nums name@"NeedRestart"                     = generateBody nums name "or"   "function NeedRestart(): Boolean"                                      ""
generateProc nums name@"GetCustomSetupExitCode"          = generateBody nums name "max"  "function GetCustomSetupExitCode(): Integer"                           ""
generateProc nums name@"InitializeUninstall"             = generateBody nums name "and"  "function InitializeUninstall(): Boolean"                              ""
generateProc nums name@"UninstallNeedRestart"            = generateBody nums name "or"   "function UninstallNeedRestart(): Boolean"                             ""


generateBody nums name how2combine header params  =  unlines$ ["", header++";","begin"] ++ map (combine.generateCall) nums ++ ["end;"]
  where generateCall n  =  name++show n++"("++params++")"
        combine call    =  case how2combine of
                             "proc" -> "  "++call++";"
                             "and"  -> "  Result := "++call++"; if not Result then exit;"
                             "or"   -> "  Result := "++call++"; if Result then exit;"
                             "max"  -> "  Result := "++call++"; if Result>0 then exit;"

{-

Result := InitializeSetup1(); if not Result then exit;



and  function InitializeSetup(): Boolean;                     Called during Setup's initialization. Return False to abort Setup, True otherwise.
and  function NextButtonClick(CurPageID: Integer): Boolean;   Called when the user clicks the Next button. If you return True, the wizard will move to the next page; if you return False, it will remain on the current page (specified by CurPageID).
and  function BackButtonClick(CurPageID: Integer): Boolean;   Called when the user clicks the Back button. If you return True, the wizard will move to the previous page; if you return False, it will remain on the current page (specified by CurPageID).
and  function ShouldSkipPage(PageID: Integer): Boolean;       The wizard calls this event function to determine whether or not a particular page (specified by PageID) should be shown at all. If you return True, the page will be skipped; if you return False, the page may be shown.
or   function NeedRestart(): Boolean;                         Return True to instruct Setup to prompt the user to restart the system at the end of a successful installation, False otherwise.
max  function GetCustomSetupExitCode: Integer;                Return a non zero number to instruct Setup to return a custom exit code. This function is only called if Setup was successfully run to completion and the exit code would have been 0. Also see Setup Exit Codes.
and  function InitializeUninstall(): Boolean;                 Return False to abort Uninstall, True otherwise.
or   function UninstallNeedRestart(): Boolean;                Return True to instruct Uninstall to prompt the user to restart the system at the end of a successful uninstallation, False otherwise.





and  function InitializeSetup
and  function NextButtonClick
and  function BackButtonClick
and  function ShouldSkipPage
or   function NeedRestart
max  function GetCustomSetupExitCode
and  function InitializeUninstall
or   function UninstallNeedRestart

-}

